perm filename ELIP.F4[SAB,LCS] blob sn#349448 filedate 1978-04-16 generic text, type C, neo UTF8
COMMENT āŠ—   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002		DIMENSION IBUF(5000)
C00004 ENDMK
CāŠ—;
	DIMENSION IBUF(5000)
	COMMON /FAC/JFAC,KFAC
	IF(JFAC.EQ.0)JFAC=100
	IF(KFAC.EQ.0)KFAC=100
	CALL PLOTS(IBUF,5000,1)
	CALL PLOT( 4., 2.  ,-3)
	A=0
	B=0
	DO 2 K=1,2
CC1	CALL ELLIPS(4.,2.,45.)
1	CALL ELLIP2(4.,2.,A,B,45.)
	A=0
2	B=-10
	CALL PLOT(0.,-30.,-3)
	CALL PLOT(0.,0.,999)
	STOP
	END
	SUBROUTINE ELLIP2(A,B,XC,YC,PSI)  
	N=IFIX(A*50.)+12
	IF(B.GT.A)N=IFIX(B*50.)+12
	PHI= (6.2831853/360.)*PSI
	X=A
	Y=0.0
	THETA=6.2831853/FLOAT(N)
	C1=COS(THETA)
	C4=A/B
	C6=SIN(THETA)
	C2=C6*C4
	C3=C6/C4
	C=COS(PHI)
	S=SIN(PHI)
	CALL PLOT(A*C+XC,A*S+YC,3)
	DO 10 I=1,N
 	U=X*C1-Y*C2
	V=X*C3+Y*C1
	X=U
	Y=V
	X1=X*C-Y*S
	Y1=X*S+Y*C
	CALL PLOT(X1+XC,Y1+YC,2)
 10	CONTINUE
	RETURN
	END